home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
lsp
/
packlib.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
5KB
|
170 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; packlib.lsp
;;;;
;;;; package routines
(in-package 'lisp)
(export '(find-all-symbols do-symbols do-external-symbols do-all-symbols))
(export '(apropos apropos-list))
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defmacro coerce-to-package (p)
(if (eq p '*package*)
p
(let ((g (gensym)))
`(let ((,g ,p))
(if (packagep ,g)
,g
(find-package (string ,g)))))))
(defun find-all-symbols (string-or-symbol)
(when (symbolp string-or-symbol)
(setq string-or-symbol (symbol-name string-or-symbol)))
(mapcan #'(lambda (p)
(multiple-value-bind (s i)
(find-symbol string-or-symbol p)
(if (or (eq i :internal) (eq i :external))
(list s)
nil)))
(list-all-packages)))
(defmacro do-symbols ((var &optional (package '*package*) (result-form nil))
. body)
(let ((p (gensym)) (i (gensym)) (l (gensym))
(loop (gensym)) (break (gensym)) declaration)
(multiple-value-setq (declaration body) (find-declarations body))
`(let ((,p (coerce-to-package ,package)) ,var ,l)
,@declaration
(dotimes (,i 1024 (progn (setq ,var nil) ,result-form))
(setq ,l (if (< ,i 512)
(si:package-internal ,p ,i)
(si:package-external ,p (- ,i 512))))
,loop
(when (null ,l) (go ,break))
(setq ,var (car ,l))
,@body
(setq ,l (cdr ,l))
(go ,loop)
,break))))
(defmacro do-external-symbols
((var &optional (package '*package*) (result-form nil)) . body)
(let ((p (gensym)) (i (gensym)) (l (gensym))
(loop (gensym)) (break (gensym)) declaration)
(multiple-value-setq (declaration body)
(find-declarations body))
`(let ((,p (coerce-to-package ,package)) ,var ,l)
,@declaration
(dotimes (,i 512 (progn (setq ,var nil) ,result-form))
(setq ,l (si:package-external ,p ,i))
,loop
(when (null ,l) (go ,break))
(setq ,var (car ,l))
,@body
(setq ,l (cdr ,l))
(go ,loop)
,break))))
(defmacro do-all-symbols ((var &optional (result-form nil)) . body)
(let ((pl (gensym)) (i (gensym)) (l (gensym))
(loop-i (gensym)) (break-i (gensym))
(loop (gensym)) (break (gensym))
declaration)
(multiple-value-setq (declaration body) (find-declarations body))
`(do ((,pl (list-all-packages) (cdr ,pl)) (,var) (,i 0 0) (,l))
((null ,pl) (setq ,var nil) ,result-form)
,@declaration
,loop-i
(when (>= ,i 1024) (go ,break-i))
(setq ,l (if (< ,i 512)
(si:package-internal (car ,pl) ,i)
(si:package-external (car ,pl) (- ,i 512))))
,loop
(when (null ,l) (go ,break))
(setq ,var (car ,l))
,@body
(setq ,l (cdr ,l))
(go ,loop)
,break
(setq ,i (1+ ,i))
(go ,loop-i)
,break-i)))
(defun substringp (sub str)
(do ((i (- (length str) (length sub)))
(l (length sub))
(j 0 (1+ j)))
((> j i) nil)
(when (string-equal sub str :start2 j :end2 (+ j l))
(return t))))
(defun print-symbol-apropos (symbol)
(prin1 symbol)
(when (fboundp symbol)
(if (special-form-p symbol)
(princ " Special form")
(if (macro-function symbol)
(princ " Macro")
(princ " Function"))))
(when (boundp symbol)
(if (constantp symbol)
(princ " Constant: ")
(princ " has value: "))
(prin1 (symbol-value symbol)))
(terpri))
(defun apropos (string &optional package)
(setq string (string string))
(cond (package
(do-symbols (symbol package)
(when (substringp string (string symbol))
(print-symbol-apropos symbol)))
(do ((p (package-use-list package) (cdr p)))
((null p))
(do-external-symbols (symbol (car p))
(when (substringp string (string symbol))
(print-symbol-apropos symbol)))))
(t
(do-all-symbols (symbol)
(when (substringp string (string symbol))
(print-symbol-apropos symbol)))))
(values))
(defun apropos-list (string &optional package &aux list)
(setq list nil)
(setq string (string string))
(cond (package
(do-symbols (symbol package)
(when (substringp string (string symbol))
(setq list (cons symbol list))))
(do ((p (package-use-list package) (cdr p)))
((null p))
(do-symbols (symbol (car p))
(when (substringp string (string symbol))
(setq list (cons symbol list))))))
(t
(do-all-symbols (symbol)
(when (substringp string (string symbol))
(setq list (cons symbol list))))))
list)